home *** CD-ROM | disk | FTP | other *** search
/ QRZ! Ham Radio 8 / QRZ Ham Radio Callsign Database - Volume 8.iso / mac / files / ant_nec / nec81tar.z / nec81tar / nfpat.f < prev    next >
Text File  |  1991-05-13  |  17KB  |  623 lines
  1. C $TITLE: 'NFPAT'
  2. C $NOFLOATCALLS
  3. C
  4. C
  5. C
  6.       SUBROUTINE NFPAT(X,Y,Z,SI,BI,SALP,
  7.      1 T1X,T1Y,T1Z,T2X,T2Y,T2Z,ICON1,ICON2,
  8.      2 AIR,AII,BIR,BII,CIR,CII,CUR,IW,LD,LD3)
  9. C     COMPUTE NEAR E OR H FIELDS OVER A RANGE OF POINTS
  10.       REAL*8 TA,CANG,CTH,STH,CPH,SPH,TMP1,TMP2,TMP3,XOB,YOB,ZOB
  11.       REAL*8 AIR,AII,BIR,BII,CIR,CII
  12. CLARGE:CUR
  13.       COMPLEX CUR
  14.       COMPLEX*16 EX,EY,EZ
  15.       INTEGER*4 ICON1,ICON2,N1,N2,N,NP,M1,M2,M,MP,IPSYM
  16.       COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
  17.       COMMON/FPAT/NTH,NPH,IPD,IAVP,INOR,IAX,THETS,PHIS,DTH,DPH,RFLD,
  18.      1 GNOR,CLT,CHT,EPSR2,SIG2,IXTYP,XPR6,PINR,PNLR,PLOSS,NEAR,NFEH,
  19.      2 NRX,NRY,NRZ,XNR,YNR,ZNR,DXNR,DYNR,DZNR
  20. C***
  21.       COMMON/PLOT/ IPLP1,IPLP2,IPLP3,IPLP4
  22. C***
  23.       DIMENSION X(LD),Y(LD),Z(LD),SI(LD),BI(LD),SALP(LD)
  24.       DIMENSION AIR(LD),AII(LD),BIR(LD),BII(LD),CIR(LD),CII(LD)
  25.       DIMENSION CUR(LD3),ICON1(LD),ICON2(LD)
  26. C***
  27. C***    PEAK FIELDS - ADD RPD   RWA 02 APR 89
  28. C***
  29.       DATA TA/1.745329252D-02/,RPD/57.29577951/
  30. C**
  31. C     D      WRITE(*,*) '  NFPAT: START'
  32. C**
  33.       IF (NFEH.EQ.1) GO TO 1
  34.       WRITE(IW,10)
  35.       GO TO 2
  36. 1     WRITE(IW,12)
  37. 2     ZNRT=ZNR-DZNR
  38.       DO 9 I=1,NRZ
  39.       ZNRT=ZNRT+DZNR
  40.       IF (NEAR.EQ.0) GO TO 3
  41.       CTH=DCOS(TA*ZNRT)
  42.       STH=DSIN(TA*ZNRT)
  43. 3     YNRT=YNR-DYNR
  44.       DO 9 J=1,NRY
  45.       YNRT=YNRT+DYNR
  46.       IF (NEAR.EQ.0) GO TO 4
  47.       CPH=DCOS(TA*YNRT)
  48.       SPH=DSIN(TA*YNRT)
  49. 4     XNRT=XNR-DXNR
  50.       DO 9 KK=1,NRX
  51.       XNRT=XNRT+DXNR
  52.       IF (NEAR.EQ.0) GO TO 5
  53.       XOB=XNRT*STH*CPH
  54.       YOB=XNRT*STH*SPH
  55.       ZOB=XNRT*CTH
  56.       GO TO 6
  57. 5     XOB=XNRT
  58.       YOB=YNRT
  59.       ZOB=ZNRT
  60. 6     TMP1=XOB/WLAM
  61.       TMP2=YOB/WLAM
  62.       TMP3=ZOB/WLAM
  63.       IF (NFEH.EQ.1) GO TO 7
  64.       CALL NEFLD (TMP1,TMP2,TMP3,EX,EY,EZ,LD,LD3,X,Y,Z,SI,BI,
  65.      1 SALP,T1Y,T1Z,T1X,T1Y,T1Z,T2X,T2Y,T2Z,ICON1,ICON2,AIR,AII,
  66.      2 BIR,BII,CIR,CII,CUR)
  67.       GO TO 8
  68. 7     CALL NHFLD (TMP1,TMP2,TMP3,EX,EY,EZ,LD,LD3,X,Y,Z,SI,BI,
  69.      1 SALP,T1Y,T1Z,T1X,T1Y,T1Z,T2X,T2Y,T2Z,AIR,AII,
  70.      2 BIR,BII,CIR,CII,CUR)
  71. C8     TMP1=CABS(EX)
  72. 8     TMP1=ZABS(EX)
  73.       TMP2=CANG(EX)
  74. C      TMP3=CABS(EY)
  75.       TMP3=ZABS(EY)
  76.       TMP4=CANG(EY)
  77. C      TMP5=CABS(EZ)
  78.       TMP5=ZABS(EZ)
  79.       TMP6=CANG(EZ)
  80. C***
  81. C***    PEAK FLD CALCULATION  RWA 02 APR 89  ADD 10 LINES/CHANGE 1
  82. C***
  83.       EZ2 = TMP5*TMP5
  84.       EY2 = TMP3*TMP3
  85.       EX2 = TMP1*TMP1
  86.       AT = EZ2*COS(TMP6*2./RPD)+EY2*COS(TMP4*2./RPD)
  87.      1 +EX2*COS(TMP2*2./RPD)
  88.       BT = EZ2*SIN(TMP6*2./RPD)+EY2*SIN(TMP4*2./RPD)
  89.      1 +EX2*SIN(TMP2*2./RPD)
  90.       CT = AT*AT+BT*BT
  91.       ETOTAL = 0.5*(EZ2+EY2+EX2)+0.5*SQRT(CT)
  92.       ETOTAL = SQRT(ETOTAL)
  93.       WRITE(IW,11)  XOB,YOB,ZOB,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,ETOTAL
  94. CCC   WRITE(IW,11)  XOB,YOB,ZOB,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6
  95. C***
  96.       IF(IPLP1 .NE. 2) GO TO 9
  97.       GO TO (14,15,16),IPLP4
  98. 14    XXX=XOB
  99.       GO TO 17
  100. 15    XXX=YOB
  101.       GO TO 17
  102. 16    XXX=ZOB
  103. 17    CONTINUE
  104.       IF(IPLP2 .NE. 2) GO TO 13
  105.       IF(IPLP3 .EQ. 1) WRITE(8,*) XXX,TMP1,TMP2
  106.       IF(IPLP3 .EQ. 2) WRITE(8,*) XXX,TMP3,TMP4
  107.       IF(IPLP3 .EQ. 3) WRITE(8,*) XXX,TMP5,TMP6
  108.       IF(IPLP3 .EQ. 4) WRITE(8,*) XXX,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6
  109. C***
  110. C***    PEAK FIELDS OUTPUT  RWA 02 APR 89  ADD 1 LINE
  111. C***
  112.       IF(IPLP3 .EQ. 5) WRITE(8,*) XXX,ETOTAL
  113.       GO TO 9
  114. 13    IF(IPLP2 .NE. 1) GO TO 9
  115.       IF(IPLP3 .EQ. 1) WRITE(8,*) XXX,EX
  116.       IF(IPLP3 .EQ. 2) WRITE(8,*) XXX,EY
  117.       IF(IPLP3 .EQ. 3) WRITE(8,*) XXX,EZ
  118.       IF(IPLP3 .EQ. 4) WRITE(8,*) XXX,EX,EY,EZ
  119. C***
  120. 9     CONTINUE
  121. C**
  122. C     D      WRITE(*,*) '  NFPAT: RETURN'
  123. C**
  124.       RETURN
  125. C
  126. C***
  127. C***      PEAK FIELDS PRINTOUT FORMAT  RWA 02 APR 89  CHANGE 17 LINES
  128. C***
  129. 10    FORMAT (///,35X,32H- - - NEAR ELECTRIC FIELDS - - -,//,12X,14H-  L
  130.      1OCATION  -,21X,8H-  EX  -,15X,8H-  EY  -,15X,8H-  EZ  -,10X,'- PEA
  131.      |K FIELDS -'/,8X,1HX,10X,
  132.      21HY,10X,1HZ,10X,9HMAGNITUDE,3X,5HPHASE,6X,9HMAGNITUDE,3X,5HPHASE,
  133.      36X,9HMAGNITUDE,3X,5HPHASE,9X,9HMAGNITUDE/,6X,6HMETERS,5X,6HMETERS
  134.      |,5X,6HMETERS,
  135.      48X,7HVOLTS/M,3X,7HDEGREES,6X,7HVOLTS/M,3X,7HDEGREES,6X,7HVOLTS/M,3
  136.      5X,7HDEGREES,9X,7HVOLTS/M)
  137. 11    FORMAT (2X,3(2X,F9.4),1X,3(3X,1P,E11.4,2X,0P,F7.2)6X,E11.4)
  138. 12    FORMAT (///,35X,32H- - - NEAR MAGNETIC FIELDS - - -,//,12X,14H-  L
  139.      1OCATION  -,21X,8H-  HX  -,15X,8H-  HY  -,15X,8H-  HZ  -,10X,'- PEA
  140.      |K FIELDS -'/,8X,1HX,10X,
  141.      21HY,10X,1HZ,10X,9HMAGNITUDE,3X,5HPHASE,6X,9HMAGNITUDE,3X,5HPHASE,
  142.      36X,9HMAGNITUDE,3X,5HPHASE,9X,9HMAGNITUDE/,6X,6HMETERS,5X,6HMETERS
  143.      |,5X,6HMETERS,
  144.      49X,6HAMPS/M,3X,7HDEGREES,7X,6HAMPS/M,3X,7HDEGREES,7X,6HAMPS/M,3X,7
  145.      5HDEGREES,9X,6HAMPS/M)
  146.       END
  147. C
  148. C
  149. C
  150.       SUBROUTINE NEFLD (XOB,YOB,ZOB,EX,EY,EZ,LD,LD3,X,Y,Z,SI,BI,
  151.      1 SALP,CAB,SAB,T1X,T1Y,T1Z,T2X,T2Y,T2Z,ICON1,ICON2,AIR,
  152.      2 AII,BIR,BII,CIR,CII,CUR)
  153. C
  154. C     NEFLD COMPUTES THE NEAR FIELD AT SPECIFIED POINTS IN SPACE AFTER
  155. C     THE STRUCTURE CURRENTS HAVE BEEN COMPUTED.
  156. C
  157.       REAL*8 ZP,XI,XOB,YOB,ZOB,AIR,AII,BIR,BII,CIR,CII
  158. CLARGE:CUR
  159.       COMPLEX CUR
  160.       COMPLEX*16 ACX,BCX,CCX,EX,EY,EZ
  161.       COMPLEX*16 EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC,
  162.      1 ZRATI,ZRATI2,T1,FRATI
  163.       INTEGER*4 ICON1,ICON2,N1,N2,N,NP,M1,M2,M,MP,IPSYM,IND1,IND2
  164.       COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
  165.       COMMON/DATAJ/S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,
  166.      1 EZS,EXC,EYC,EZC,RKH,IND1,IND2,IPGND,IEXK
  167.       COMMON/GND/ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,
  168.      1 IFAR,IPERF,T1,T2
  169.       DIMENSION X(LD),Y(LD),Z(LD),SI(LD),BI(LD),SALP(LD)
  170.       DIMENSION AIR(LD),AII(LD),BIR(LD),BII(LD),CIR(LD),CII(LD)
  171.       DIMENSION CUR(LD3),ICON1(LD),ICON2(LD)
  172.       DIMENSION T1X(LD),T1Y(LD),T1Z(LD),T2X(LD),T2Y(LD),T2Z(LD),
  173.      1 CAB(LD),SAB(LD)
  174.       EQUIVALENCE (T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2Y
  175.      1J,IND1), (T2ZJ,IND2)
  176. C**
  177. C     E      WRITE(*,*) '   NEFLD: START'
  178. C**
  179.       EX=(0.,0.)
  180.       EY=(0.,0.)
  181.       EZ=(0.,0.)
  182.       AX=0.
  183.       IF (N.EQ.0) GO TO 20
  184.       DO 1 I=1,N
  185.       XJ=XOB-X(I)
  186.       YJ=YOB-Y(I)
  187.       ZJ=ZOB-Z(I)
  188.       ZP=CAB(I)*XJ+SAB(I)*YJ+SALP(I)*ZJ
  189.       IF(DABS(ZP).GT.0.5001D0*SI(I)) GO TO 1
  190.       ZP=XJ*XJ+YJ*YJ+ZJ*ZJ-ZP*ZP
  191.       XJ=BI(I)
  192.       IF (ZP.GT.0.9*XJ*XJ) GO TO 1
  193.       AX=XJ
  194.       GO TO 2
  195. 1     CONTINUE
  196. 2     DO 19 I=1,N
  197.       S=SI(I)
  198.       B=BI(I)
  199.       XJ=X(I)
  200.       YJ=Y(I)
  201.       ZJ=Z(I)
  202.       CABJ=CAB(I)
  203.       SABJ=SAB(I)
  204.       SALPJ=SALP(I)
  205.       IF (IEXK.EQ.0) GO TO 18
  206.       IPR=ICON1(I)
  207.       IF (IPR) 3,8,4
  208. 3     IPR=-IPR
  209.       IF (-ICON1(IPR).NE.I) GO TO 9
  210.       GO TO 6
  211. 4     IF (IPR.NE.I) GO TO 5
  212.       IF (CABJ*CABJ+SABJ*SABJ.GT.1.E-8) GO TO 9
  213.       GO TO 7
  214. 5     IF (ICON2(IPR).NE.I) GO TO 9
  215. C6     XI=DABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))
  216. 6     XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))
  217.       IF (XI.LT.0.999999D0) GO TO 9
  218.       IF (ABS(BI(IPR)/B-1.).GT.1.E-6) GO TO 9
  219. 7     IND1=0
  220.       GO TO 10
  221. 8     IND1=1
  222.       GO TO 10
  223. 9     IND1=2
  224. 10    IPR=ICON2(I)
  225.       IF (IPR) 11,16,12
  226. 11    IPR=-IPR
  227.       IF (-ICON2(IPR).NE.I) GO TO 17
  228.       GO TO 14
  229. 12    IF (IPR.NE.I) GO TO 13
  230.       IF (CABJ*CABJ+SABJ*SABJ.GT.1.E-8) GO TO 17
  231.       GO TO 15
  232. 13    IF (ICON1(IPR).NE.I) GO TO 17
  233. C14    XI=DABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))
  234. 14    XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))
  235.       IF (XI.LT.0.999999D0) GO TO 17
  236.       IF (ABS(BI(IPR)/B-1.).GT.1.E-6) GO TO 17
  237. 15    IND2=0
  238.       GO TO 18
  239. 16    IND2=1
  240.       GO TO 18
  241. 17    IND2=2
  242. 18    CONTINUE
  243.       CALL EFLD (XOB,YOB,ZOB,AX,1)
  244.       ACX=DCMPLX(AIR(I),AII(I))
  245.       BCX=DCMPLX(BIR(I),BII(I))
  246.       CCX=DCMPLX(CIR(I),CII(I))
  247.       EX=EX+EXK*ACX+EXS*BCX+EXC*CCX
  248.       EY=EY+EYK*ACX+EYS*BCX+EYC*CCX
  249. 19    EZ=EZ+EZK*ACX+EZS*BCX+EZC*CCX
  250.       IF (M.EQ.0) GOTO 22
  251. 20    JC=N
  252.       JL=LD+1
  253.       DO 21 I=1,M
  254.       JL=JL-1
  255.       S=BI(JL)
  256.       XJ=X(JL)
  257.       YJ=Y(JL)
  258.       ZJ=Z(JL)
  259.       T1XJ=T1X(JL)
  260.       T1YJ=T1Y(JL)
  261.       T1ZJ=T1Z(JL)
  262.       T2XJ=T2X(JL)
  263.       T2YJ=T2Y(JL)
  264.       T2ZJ=T2Z(JL)
  265.       JC=JC+3
  266.       ACX=T1XJ*CUR(JC-2)+T1YJ*CUR(JC-1)+T1ZJ*CUR(JC)
  267.       BCX=T2XJ*CUR(JC-2)+T2YJ*CUR(JC-1)+T2ZJ*CUR(JC)
  268.       DO 21 IP=1,KSYMP
  269.       IPGND=IP
  270.       CALL UNERE (XOB,YOB,ZOB)
  271.       EX=EX+ACX*EXK+BCX*EXS
  272.       EY=EY+ACX*EYK+BCX*EYS
  273.       EZ=EZ+ACX*EZK+BCX*EZS
  274. 21      CONTINUE
  275. 22      CONTINUE
  276. C**
  277. C     E      WRITE(*,*) '   NEFLD: RETURN'
  278. C**
  279.       RETURN
  280.       END
  281. C
  282. C
  283. C
  284.       SUBROUTINE NHFLD (XOB,YOB,ZOB,HX,HY,HZ,LD,LD3,X,Y,Z,SI,BI,
  285.      1 SALP,CAB,SAB,T1X,T1Y,T1Z,T2X,T2Y,T2Z,AIR,
  286.      2 AII,BIR,BII,CIR,CII,CUR)
  287. C
  288. C     NHFLD COMPUTES THE NEAR FIELD AT SPECIFIED POINTS IN SPACE AFTER
  289. C     THE STRUCTURE CURRENTS HAVE BEEN COMPUTED.
  290. C
  291.       REAL*8 XOB,YOB,ZOB,AIR,AII,BIR,BII,CIR,CII
  292. CLARGE: CUR
  293.       COMPLEX CUR
  294.       COMPLEX*16 ACX,BCX,CCX,HX,HY,HZ
  295.       COMPLEX*16 EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC
  296.       INTEGER*4 N1,N2,N,NP,M1,M2,M,MP,IPSYM,IND1,IND2
  297.       COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
  298.       COMMON/DATAJ/S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,
  299.      1 EZS,EXC,EYC,EZC,RKH,IND1,IND2,IPGND,IEXK
  300.       DIMENSION X(LD),Y(LD),Z(LD),SI(LD),BI(LD),SALP(LD)
  301.       DIMENSION AIR(LD),AII(LD),BIR(LD),BII(LD),CIR(LD),CII(LD)
  302.       DIMENSION CUR(LD3)
  303.       DIMENSION T1X(LD),T1Y(LD),T1Z(LD),T2X(LD),T2Y(LD),T2Z(LD),
  304.      1 CAB(LD),SAB(LD)
  305.       EQUIVALENCE (T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2Y
  306.      1J,IND1), (T2ZJ,IND2)
  307. C**
  308. C     E      WRITE(*,*) '   NHFLD: RETURN'
  309. C**
  310.       HX=(0.,0.)
  311.       HY=(0.,0.)
  312.       HZ=(0.,0.)
  313.       AX=0.
  314.       IF (N.EQ.0) GO TO 4
  315.       DO 1 I=1,N
  316.       XJ=XOB-X(I)
  317.       YJ=YOB-Y(I)
  318.       ZJ=ZOB-Z(I)
  319.       ZP=CAB(I)*XJ+SAB(I)*YJ+SALP(I)*ZJ
  320.       IF (ABS(ZP).GT.0.5001*SI(I)) GO TO 1
  321.       ZP=XJ*XJ+YJ*YJ+ZJ*ZJ-ZP*ZP
  322.       XJ=BI(I)
  323.       IF (ZP.GT.0.9*XJ*XJ) GO TO 1
  324.       AX=XJ
  325.       GO TO 2
  326. 1     CONTINUE
  327. 2     DO 3 I=1,N
  328.       S=SI(I)
  329.       B=BI(I)
  330.       XJ=X(I)
  331.       YJ=Y(I)
  332.       ZJ=Z(I)
  333.       CABJ=CAB(I)
  334.       SABJ=SAB(I)
  335.       SALPJ=SALP(I)
  336.       CALL HSFLD (XOB,YOB,ZOB,AX)
  337.       ACX=DCMPLX(AIR(I),AII(I))
  338.       BCX=DCMPLX(BIR(I),BII(I))
  339.       CCX=DCMPLX(CIR(I),CII(I))
  340.       HX=HX+EXK*ACX+EXS*BCX+EXC*CCX
  341.       HY=HY+EYK*ACX+EYS*BCX+EYC*CCX
  342. 3     HZ=HZ+EZK*ACX+EZS*BCX+EZC*CCX
  343.       IF (M.EQ.0) GOTO 6
  344. 4     JC=N
  345.       JL=LD+1
  346.       DO 5 I=1,M
  347.       JL=JL-1
  348.       S=BI(JL)
  349.       XJ=X(JL)
  350.       YJ=Y(JL)
  351.       ZJ=Z(JL)
  352.       T1XJ=T1X(JL)
  353.       T1YJ=T1Y(JL)
  354.       T1ZJ=T1Z(JL)
  355.       T2XJ=T2X(JL)
  356.       T2YJ=T2Y(JL)
  357.       T2ZJ=T2Z(JL)
  358.       CALL HINTG (XOB,YOB,ZOB)
  359.       JC=JC+3
  360.       ACX=T1XJ*CUR(JC-2)+T1YJ*CUR(JC-1)+T1ZJ*CUR(JC)
  361.       BCX=T2XJ*CUR(JC-2)+T2YJ*CUR(JC-1)+T2ZJ*CUR(JC)
  362.       HX=HX+ACX*EXK+BCX*EXS
  363.       HY=HY+ACX*EYK+BCX*EYS
  364.       HZ=HZ+ACX*EZK+BCX*EZS
  365. 5      CONTINUE
  366. 6      CONTINUE
  367. C**
  368. C     E      WRITE(*,*) '   NHFLD: RETURN'
  369. C**
  370.       RETURN
  371.       END
  372. C
  373. C
  374. C
  375.       SUBROUTINE EFLD (XI,YI,ZI,AI,IJ)
  376. C
  377. C     COMPUTE NEAR E FIELDS OF A SEGMENT WITH SINE, COSINE, AND
  378. C     CONSTANT CURRENTS.  GROUND EFFECT INCLUDED.
  379. C
  380.       INTEGER*4 IND1,IND2
  381.       REAL*8 PI,TP,R,RMAG,XYMAG,XSPEC,YSPEC,RHOSPC,CTH,PX,PY,DMIN,
  382.      1 SHAF,XI,YI,ZI
  383.       COMPLEX*16 EGND(9),TXK,TYK,TZK,TXS,TYS,TZS,TXC,TYC,TZC,
  384.      1 TEZS,TERS,TEZC,TERC,TEZK,TERK
  385.       COMPLEX*16 EXK,EYK,EZK,EXS,EYS,ZRATI,ZRATI2,T1,FRATI,
  386.      1 EZS,EXC,EYC,EZC,EPX,EPY,REFS,REFPS,ZRSIN,ZRATX,ZSCRN
  387.       COMMON/DATAJ/S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,
  388.      1 EZS,EXC,EYC,EZC,RKH,IND1,IND2,IPGND,IEXK
  389.       COMMON/GND/ ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,
  390.      1 IFAR,IPERF,T1,T2
  391.       COMMON/INCOM/ XO,YO,ZO,SN,XSN,YSN,ISNOR
  392.       EQUIVALENCE (EGND(1),TXK),(EGND(2),TYK),(EGND(3),TZK),(EGND(4),
  393.      1TXS),(EGND(5),TYS),(EGND(6),TZS),(EGND(7),TXC),(EGND(8),TYC),
  394.      2(EGND(9),TZC)
  395.       DATA ETA/376.73/,PI/3.141592654D0/,TP/6.283185308D0/
  396. C**
  397. C     D      WRITE(*,*) '   EFLD: START'
  398. C**
  399.       XIJ=XI-XJ
  400.       YIJ=YI-YJ
  401.       IJX=IJ
  402.       RFL=-1.
  403.       DO 12 IP=1,KSYMP
  404.       IF (IP.EQ.2) IJX=1
  405.       RFL=-RFL
  406.       SALPR=SALPJ*RFL
  407.       ZIJ=ZI-RFL*ZJ
  408.       ZP=XIJ*CABJ+YIJ*SABJ+ZIJ*SALPR
  409.       RHOX=XIJ-CABJ*ZP
  410.       RHOY=YIJ-SABJ*ZP
  411.       RHOZ=ZIJ-SALPR*ZP
  412. C      RH=DSQRT(RHOX*RHOX+RHOY*RHOY+RHOZ*RHOZ+AI*AI)
  413.       RH=SQRT(RHOX*RHOX+RHOY*RHOY+RHOZ*RHOZ+AI*AI)
  414.       IF (RH.GT.1.E-10) GO TO 1
  415.       RHOX=0.
  416.       RHOY=0.
  417.       RHOZ=0.
  418.       GO TO 2
  419. 1     RHOX=RHOX/RH
  420.       RHOY=RHOY/RH
  421.       RHOZ=RHOZ/RH
  422. C2     R=DSQRT(ZP*ZP+RH*RH)
  423. 2     R=SQRT(ZP*ZP+RH*RH)
  424.       IF (R.LT.RKH) GO TO 3
  425. C
  426. C     LUMPED CURRENT ELEMENT APPROX. FOR LARGE SEPARATIONS
  427. C
  428.       RMAG=TP*R
  429.       CTH=ZP/R
  430.       PX=RH/R
  431.       TXK=DCMPLX(DCOS(RMAG),-DSIN(RMAG))
  432.       PY=TP*R*R
  433.       TYK=ETA*CTH*TXK*DCMPLX(1.,-1./RMAG)/PY
  434.       TZK=ETA*PX*TXK*DCMPLX(1.,RMAG-1./RMAG)/(2.*PY)
  435.       TEZK=TYK*CTH-TZK*PX
  436.       TERK=TYK*PX+TZK*CTH
  437.       RMAG=DSIN(PI*S)/PI
  438.       TEZC=TEZK*RMAG
  439.       TERC=TERK*RMAG
  440.       TEZK=TEZK*S
  441.       TERK=TERK*S
  442.       TXS=(0.,0.)
  443.       TYS=(0.,0.)
  444.       TZS=(0.,0.)
  445.       GO TO 6
  446. 3     IF (IEXK.EQ.1) GO TO 4
  447. C
  448. C     EKSC FOR THIN WIRE APPROX. OR EKSCX FOR EXTENDED T.W. APPROX.
  449. C
  450.       CALL EKSC (S,ZP,RH,TP,IJX,TEZS,TERS,TEZC,TERC,TEZK,TERK)
  451.       GO TO 5
  452. 4      CONTINUE
  453.       CALL EKSCX(B,S,ZP,RH,TP,IJX,IND1,IND2,TEZS,TERS,TEZC,TERC,TEZK,
  454.      1TERK)
  455. 5     TXS=TEZS*CABJ+TERS*RHOX
  456.       TYS=TEZS*SABJ+TERS*RHOY
  457.       TZS=TEZS*SALPR+TERS*RHOZ
  458. 6     TXK=TEZK*CABJ+TERK*RHOX
  459.       TYK=TEZK*SABJ+TERK*RHOY
  460.       TZK=TEZK*SALPR+TERK*RHOZ
  461.       TXC=TEZC*CABJ+TERC*RHOX
  462.       TYC=TEZC*SABJ+TERC*RHOY
  463.       TZC=TEZC*SALPR+TERC*RHOZ
  464.       IF (IP.NE.2) GO TO 11
  465.       IF (IPERF.GT.0) GO TO 10
  466.       ZRATX=ZRATI
  467.       RMAG=R
  468. C      XYMAG=DSQRT(XIJ*XIJ+YIJ*YIJ)
  469.       XYMAG=SQRT(XIJ*XIJ+YIJ*YIJ)
  470. C
  471. C     SET PARAMETERS FOR RADIAL WIRE GROUND SCREEN.
  472. C
  473.       IF (NRADL.EQ.0) GO TO 7
  474.       XSPEC=(XI*ZJ+ZI*XJ)/(ZI+ZJ)
  475.       YSPEC=(YI*ZJ+ZI*YJ)/(ZI+ZJ)
  476.       RHOSPC=DSQRT(XSPEC*XSPEC+YSPEC*YSPEC+T2*T2)
  477.       IF (RHOSPC.GT.SCRWL) GO TO 7
  478.       ZSCRN=T1*RHOSPC*DLOG(RHOSPC/T2)
  479.       ZRATX=(ZSCRN*ZRATI)/(ETA*ZRATI+ZSCRN)
  480. 7     IF (XYMAG.GT.1.D-6) GO TO 8
  481. C
  482. C     CALCULATION OF REFLECTION COEFFICIENTS WHEN GROUND IS SPECIFIED.
  483. C
  484.       PX=0.
  485.       PY=0.
  486.       CTH=1.
  487.       ZRSIN=(1.,0.)
  488.       GO TO 9
  489. 8     PX=-YIJ/XYMAG
  490.       PY=XIJ/XYMAG
  491.       CTH=ZIJ/RMAG
  492.       ZRSIN=CDSQRT(1.-ZRATX*ZRATX*(1.-CTH*CTH))
  493. 9     REFS=(CTH-ZRATX*ZRSIN)/(CTH+ZRATX*ZRSIN)
  494.       REFPS=-(ZRATX*CTH-ZRSIN)/(ZRATX*CTH+ZRSIN)
  495.       REFPS=REFPS-REFS
  496.       EPY=PX*TXK+PY*TYK
  497.       EPX=PX*EPY
  498.       EPY=PY*EPY
  499.       TXK=REFS*TXK+REFPS*EPX
  500.       TYK=REFS*TYK+REFPS*EPY
  501.       TZK=REFS*TZK
  502.       EPY=PX*TXS+PY*TYS
  503.       EPX=PX*EPY
  504.       EPY=PY*EPY
  505.       TXS=REFS*TXS+REFPS*EPX
  506.       TYS=REFS*TYS+REFPS*EPY
  507.       TZS=REFS*TZS
  508.       EPY=PX*TXC+PY*TYC
  509.       EPX=PX*EPY
  510.       EPY=PY*EPY
  511.       TXC=REFS*TXC+REFPS*EPX
  512.       TYC=REFS*TYC+REFPS*EPY
  513.       TZC=REFS*TZC
  514. 10    EXK=EXK-TXK*FRATI
  515.       EYK=EYK-TYK*FRATI
  516.       EZK=EZK-TZK*FRATI
  517.       EXS=EXS-TXS*FRATI
  518.       EYS=EYS-TYS*FRATI
  519.       EZS=EZS-TZS*FRATI
  520.       EXC=EXC-TXC*FRATI
  521.       EYC=EYC-TYC*FRATI
  522.       EZC=EZC-TZC*FRATI
  523.       GO TO 12
  524. 11    EXK=TXK
  525.       EYK=TYK
  526.       EZK=TZK
  527.       EXS=TXS
  528.       EYS=TYS
  529.       EZS=TZS
  530.       EXC=TXC
  531.       EYC=TYC
  532.       EZC=TZC
  533. 12    CONTINUE
  534.       IF (IPERF.EQ.2) GO TO 13
  535. C**
  536. C     D      WRITE(*,*) '   EFLD: RETURN LINE 161'
  537. C**
  538.       RETURN
  539. C
  540. C     FIELD DUE TO GROUND USING SOMMERFELD/NORTON
  541. C
  542. C13    SN=DSQRT(CABJ*CABJ+SABJ*SABJ)
  543. 13    SN=SQRT(CABJ*CABJ+SABJ*SABJ)
  544.       IF (SN.LT.1.E-5) GO TO 14
  545.       XSN=CABJ/SN
  546.       YSN=SABJ/SN
  547.       GO TO 15
  548. 14    SN=0.
  549.       XSN=1.
  550.       YSN=0.
  551. C
  552. C     DISPLACE OBSERVATION POINT FOR THIN WIRE APPROXIMATION
  553. C
  554. 15    ZIJ=ZI+ZJ
  555.       SALPR=-SALPJ
  556.       RHOX=SABJ*ZIJ-SALPR*YIJ
  557.       RHOY=SALPR*XIJ-CABJ*ZIJ
  558.       RHOZ=CABJ*YIJ-SABJ*XIJ
  559.       RH=RHOX*RHOX+RHOY*RHOY+RHOZ*RHOZ
  560.       IF (RH.GT.1.E-10) GO TO 16
  561.       XO=XI-AI*YSN
  562.       YO=YI+AI*XSN
  563.       ZO=ZI
  564.       GO TO 17
  565. C16    RH=AI/DSQRT(RH)
  566. 16    RH=AI/SQRT(RH)
  567.       IF (RHOZ.LT.0.) RH=-RH
  568.       XO=XI+RH*RHOX
  569.       YO=YI+RH*RHOY
  570.       ZO=ZI+RH*RHOZ
  571. 17    R=XIJ*XIJ+YIJ*YIJ+ZIJ*ZIJ
  572.       IF (R.GT..95) GO TO 18
  573. C
  574. C     FIELD FROM INTERPOLATION IS INTEGRATED OVER SEGMENT
  575. C
  576.       ISNOR=1
  577.       DMIN=EXK*DCONJG(EXK)+EYK*DCONJG(EYK)+EZK*DCONJG(EZK)
  578.       DMIN=.01*DSQRT(DMIN)
  579.       SHAF=.5*S
  580.       CALL ROM2 (-SHAF,SHAF,EGND,DMIN)
  581.       GO TO 19
  582. C
  583. C     NORTON FIELD EQUATIONS AND LUMPED CURRENT ELEMENT APPROXIMATION
  584. C
  585. 18    ISNOR=2
  586.       CALL SFLDS (0.D0,EGND)
  587.       GO TO 22
  588. 19    ZP=XIJ*CABJ+YIJ*SABJ+ZIJ*SALPR
  589.       RH=R-ZP*ZP
  590.       IF (RH.GT.1.E-10) GO TO 20
  591.       DMIN=0.
  592.       GO TO 21
  593. C20    DMIN=DSQRT(RH/(RH+AI*AI))
  594. 20    DMIN=SQRT(RH/(RH+AI*AI))
  595. 21    IF (DMIN.GT..95) GO TO 22
  596.       PX=1.-DMIN
  597.       TERK=(TXK*CABJ+TYK*SABJ+TZK*SALPR)*PX
  598.       TXK=DMIN*TXK+TERK*CABJ
  599.       TYK=DMIN*TYK+TERK*SABJ
  600.       TZK=DMIN*TZK+TERK*SALPR
  601.       TERS=(TXS*CABJ+TYS*SABJ+TZS*SALPR)*PX
  602.       TXS=DMIN*TXS+TERS*CABJ
  603.       TYS=DMIN*TYS+TERS*SABJ
  604.       TZS=DMIN*TZS+TERS*SALPR
  605.       TERC=(TXC*CABJ+TYC*SABJ+TZC*SALPR)*PX
  606.       TXC=DMIN*TXC+TERC*CABJ
  607.       TYC=DMIN*TYC+TERC*SABJ
  608.       TZC=DMIN*TZC+TERC*SALPR
  609. 22    EXK=EXK+TXK
  610.       EYK=EYK+TYK
  611.       EZK=EZK+TZK
  612.       EXS=EXS+TXS
  613.       EYS=EYS+TYS
  614.       EZS=EZS+TZS
  615.       EXC=EXC+TXC
  616.       EYC=EYC+TYC
  617.       EZC=EZC+TZC
  618. C**
  619. C     D      WRITE(*,*) '   EFLD: RETURN LINE 241'
  620. C**
  621.       RETURN
  622.       END
  623.